(* ===================================================================== *)
(** Outils de travail pour bopbdd
  @author Ana Todorova, Mathieu Barbin *)
(* ===================================================================== *)

open Bplib

let fct_etoile = true
let etoile = "et ()"

(** <h2> MUXTREE : arbre brut de mux </h2> *)

(* ===================================================================== *)
(** Le type pour gerer l'arbre de mux avec des don't care *)
(* ===================================================================== *)
type muxtree = 
  | Constant of bool option
  | Signal of string
  | NotSignal of string
  | Mux of int * muxtree * muxtree 
(* ===================================================================== *)

(* ===================================================================== *)
(** Affichage sommaire d'un arbre de mux avec des tabulations *)
(* ===================================================================== *)
let string_of_muxtree muxt = 
  let indent num = String.make num '\t' in
  let rec aux indent_num muxtree = 
    let indent_string = indent indent_num in
    match muxtree with
      | Constant (Some true) -> indent_string^"1"
      | Constant (Some false) -> indent_string^"0"
      | Constant None -> indent_string^etoile
      | Signal i -> indent_string^i
      | NotSignal i -> Printf.sprintf "%snot( %s )" indent_string i
      | Mux (value, mux_then, mux_else) ->
          Printf.sprintf "%smux( a[%d] ,\n%s,\n%s\n%s)" indent_string value 
          (aux (succ indent_num) mux_then) (aux (succ indent_num) mux_else) indent_string
  in (aux 0 muxt)^";"
(* ===================================================================== *)

(* ===================================================================== *)
(** Gestion d'un AVL indexe par des muxtree : cf fonctor Map *)
(* ===================================================================== *)
module MuxTreeOrder : (Map.OrderedType with type t = muxtree) =
struct
  type t = muxtree
  let compare_bool_option a b =
    match a, b with
    | None , Some _ -> -1
    | Some _, None -> 1
    | None, None -> 0
    | Some u, Some v -> Pervasives.compare u v
      
  (* Constant < NotSignal < Signal < Mux *)

  let compare a b = 
    let rec aux = function
	(* 1) Mux *)
      | Mux ( i, m1_Vdd, m1_Gnd), Mux ( j, m2_Vdd, m2_Gnd) ->
	  let r = Pervasives.compare i j in 
	  if r <> 0 then r
	  else
	    (* ordre lexicographique sur les sous-arbres *)
	    let r2 = aux (m1_Vdd, m2_Vdd) in
	    if r2 <> 0 then r2 else aux (m1_Gnd, m2_Gnd)
	(* signal vs mux *)
      | _ , Mux _ -> -1
      | Mux _, _ -> 1
	  (* 2) Signal *)
      | Signal i, Signal j -> Pervasives.compare i j
      | _, Signal _ -> -1
      | Signal _, _ -> 1
	  (* 3) NotSignal *)
      | NotSignal i, NotSignal j -> Pervasives.compare i j
      | _, NotSignal _ -> -1
      | NotSignal _, _ -> 1
	  (* 4) Constant *)
      | Constant bo, Constant bo2 -> compare_bool_option bo bo2
    in aux (a, b)
end

module MuxTreeMap = Map.Make (MuxTreeOrder)
(* ===================================================================== *)

(* ===================================================================== *)
(** Normalisation d'un muxtree : optimisation immediate *)
(* ===================================================================== *)
let rec normalised_mux_tree = function
  | (Constant _) as t -> t
  | (Signal _) as t -> t
  | (NotSignal _) as t -> t
  | Mux (i, m1, m2) -> 
      begin
	match normalised_mux_tree m1, normalised_mux_tree m2 with
	  (* elimination de l'etoile *)
	| Constant None, fix -> fix
	| fix, Constant None -> fix
	    (* identite *)
	| Constant (Some true) , Constant (Some false) -> Signal (Printf.sprintf "a[%d]" i)
		(* negation *)
	| Constant (Some false), Constant (Some true) -> NotSignal (Printf.sprintf "a[%d]" i)
	| nm1, nm2 ->
	    if MuxTreeOrder.compare nm1 nm2 = 0
	    then nm1
	    else Mux (i, nm1, nm2)	
	  end
(* ===================================================================== *)

(*
begin
	(* essai : optimisation par un swap de reordering *)
	match nm1, nm2 with
	| Mux(j, a, b), Mux(k, c, d) when j = k ->
		(* si a = c ou b = d ça vaut le coup de renverser *)
		if MuxTreeOrder.compare a c = 0
		then Mux(j, a, Mux(i, b, d)) (* economie : 1 Mux *)
		else 
			if MuxTreeOrder.compare b d = 0
			then Mux(j, Mux(i, a, c), b) (* economie : 1 Mux *)
			else Mux(i, nm1, nm2)
	| _ -> Mux (i, nm1, nm2)
end
*)

(* ===================================================================== *)
(** Charger un partial rom a partir d'un fichier, puis construire les arbres de mux 
  On appelle par defaut les entree a comme adresse *)
(* ===================================================================== *)
let raw_tree_of_partial_bool_matrix pbm =
  let len = Array.length pbm in
  let adresse = log2 len in
  let mot = Array.length pbm.(0) in
  (* on doit construire autant d'arbre que de bits de mot *)
  (* Printf.fprintf stderr "Rendu du log : len = %d, adresse = %d\n" len adresse; flush stderr; *)
  let muxtree i =
    (* les bits de poids faibles à gauche : donc on ajoute 2^j ou rien *)
    let rec aux puiss2 accu j =
      if j = adresse
      then Constant pbm.(accu).(i)
      else
        (* On construit une branche de mux *)
        let puiss22 = puiss2 * 2 in
        let succ_j = succ j in
        begin
          Mux ( j,
           (aux puiss22 (accu + puiss2) succ_j),
           (aux puiss22 accu succ_j)
          )
        end
    in normalised_mux_tree (aux 1 0 0)
  in
  Array.init mot muxtree
(* ===================================================================== *)

(* ===================================================================== *)
(** On demande importe un tableau partiel, et on affiche son arbre *)
(* ===================================================================== *)
let print_raw_tree_of_file print ad word file =
  let pbm = PartialBoolMatrix.of_asci_file (2 $$ ad) word file in
  let tree = raw_tree_of_partial_bool_matrix pbm in
  begin
    print (Printf.sprintf "// Bloc muxtree macro-genere par muxtree a partir de %s\n\n" file);
    if fct_etoile 
    then print "et () = s\nwhere\n s = vdd ();\nend where;\n\n"
    else ();
    print (Printf.sprintf "Bloc ( a:[%d] ) = ( out:[%d] ) \nwhere\n" ad word); 
    for i = 0 to pred word do
      let string_tree = string_of_muxtree tree.(i) in 
      print (Printf.sprintf "out[%d] = \n%s\n\n" i string_tree)
    done;
    print "\nend where;\n"
  end
(* ===================================================================== *)


(** <h2> MUXLIST : list d'equation de bases de mux a partir de l'arbre </h2> *)

(* ===================================================================== *)
(** On depasse max int lors de la creation de fresh name
    (bravo a celui qui a ecrit la net_list) *)  
(* ===================================================================== *)
exception FreshOverflow 
(* ===================================================================== *)

(* ===================================================================== *)
(** Creer une fonction qui creer des freshs, a partir d'une fonction 
    de transformation des entiers *)  
(* ===================================================================== *)
let fresh_fct_factory transf =
  let index = ref 0 in
  let fresh_name () = 
    begin
      (
       if !index < max_int 
       then incr(index)
       else raise FreshOverflow 
      );
     transf (!index)
    end
  and fresh_init () = index := 0
  in (fresh_name,fresh_init)
(* ===================================================================== *)

(* ===================================================================== *)
(** Le type pour gerer la liste des mux avec des don't care *)
(* ===================================================================== *)
type muxlist = muxnode list
and muxnode = 
    {
      output : string;
      muxtree : muxtree
    }
(* ===================================================================== *)

(* ===================================================================== *)
(** Affichage sommaire d'une liste de mux a plat *)
(* ===================================================================== *)
let string_of_muxnode muxn = 
  let rec aux = function
    | Constant (Some true) -> "1"
    | Constant (Some false) -> "0"
    | Constant None -> etoile
    | Signal i -> i
    | NotSignal i -> Printf.sprintf "not( %s )" i
    | Mux (value, mux_then, mux_else) -> Printf.sprintf "mux( a[%d], %s, %s)" value (aux mux_then) (aux mux_else)
  in
  Printf.sprintf "%s = %s;" muxn.output (aux muxn.muxtree)
(* ===================================================================== *)

(* ===================================================================== *)
(** Charger un partial rom a partir d'un fichier, puis construire les listes de mux 
    On appelle par defaut les entree a comme adresse *)
(* ===================================================================== *)
let mux_list_of_mux_tree tree_tab = 
  (* gestion des fresh *)
  let fresh, _ = fresh_fct_factory (fun i -> Printf.sprintf "s%d" i) in
  (* gestion de la collection d'arbre pour les signaux partages *)
  let muxMap = ref MuxTreeMap.empty in
  (* gestion des noeuds a produire *)
  let nodeS = Stack.create () in
  (* Ajout d'un arbre dans la table pour partage et retour son index*)
  let num_node = ref 0 in
  let share_tree tree =
	incr(num_node);
	(* 1) lui donner un nom *)
	let fresh_mux = fresh () in
	(* 2) l'ajouter dans la collection *)
	muxMap := MuxTreeMap.add tree fresh_mux (!muxMap);
	(* produire le noeud correspondant *)
	let fresh_node =
		{ 
			output = fresh_mux;
			muxtree = tree;
		} in
	Stack.push fresh_node nodeS;
	(* finalement, rendre le nom d'acces a ce nouvel arbre disponible *)
	Signal fresh_mux
  in
  (* traitement de l'arbre de mux de la sortie d'index i *)
  let traite_tree i tree = 
    let rec aux tree =  
      let norm_tree = normalised_mux_tree tree in
      try
	Signal (MuxTreeMap.find norm_tree !muxMap)
      with
      | Not_found ->
	  begin
	    match norm_tree with
		(* ca vaut le coupe de garder le signal nié une fois pour toute *)
	    | NotSignal i -> share_tree norm_tree	
	    | Constant _ | Signal _ -> norm_tree
	    | Mux (j, mux_vdd, mux_gnd) -> 
		let sortie_vdd = aux mux_vdd and sortie_gnd = aux mux_gnd in
		let norm_result = normalised_mux_tree (Mux (j, sortie_vdd, sortie_gnd)) in
		(* on peut etre en presence de cet arbre normalise *)
		begin
		  try
		    Signal (MuxTreeMap.find norm_result !muxMap)
		  with
		  | Not_found ->
		      begin
			match norm_result with
			| Constant _ | Signal _ -> norm_result 
			| _ -> share_tree norm_result
			  end
		end
	  end
    in 
    Stack.push { output = Printf.sprintf "out[%d]" i ; muxtree =  aux tree } nodeS
  in 
  begin 
    (* on remplit les structures avec un parcours recursif qui joue par effet de bord *)
    Array.iteri traite_tree tree_tab;
    (* on exporte les donnees *)
    let rec aux accu = 
      if Stack.is_empty nodeS 
      then accu
      else aux ((Stack.pop nodeS)::accu)
    in ((aux []), !num_node)
  end
(* ===================================================================== *)

(* ===================================================================== *)
(** On demande importe un tableau partiel, et on affiche sa liste *)
(* ===================================================================== *)
let print_raw_list_of_file print ad word file =
  let len = 2 $$ ad in
  let pbm = PartialBoolMatrix.of_asci_file len word file in
  let tree = raw_tree_of_partial_bool_matrix pbm in
  let list, num_node = mux_list_of_mux_tree tree in
  begin
    print (Printf.sprintf "// Bloc muxlist macro-genere par muxlist a partir de %s\n\n" file);
    if fct_etoile 
    then print "et () = s\nwhere\n s = vdd ();\nend where;\n\n"
    else ();
    print (Printf.sprintf "Bloc ( a:[%d] ) = ( out:[%d] ) \nwhere\n" ad word); 
    List.iter (fun s -> print ("\t"^(string_of_muxnode s)^"\n")) list;
    print "end where;\n";
    let full_gate = (len - 1) * word in
    let prop = (float_of_int num_node /. float_of_int full_gate) *. 100. in
    Printf.fprintf stderr "Gate count : %d / %d ( %2.3f %c)\n" num_node full_gate prop '%';
    flush stderr;
  end
(* ===================================================================== *)
